home *** CD-ROM | disk | FTP | other *** search
/ MacHack 1997 / MacHack 1997.toast / Presentations / Presentations ’93 / Voice Toolkit / QuickDraw.lisp next >
Encoding:
Text File  |  1991-11-07  |  19.7 KB  |  585 lines  |  [TEXT/CCL2]
  1. ;;-*- Mode: Lisp; Package: CCL -*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;  Quickdraw.lisp
  4. ;;
  5. ;;  version 2.0
  6. ;;
  7. ;;  copyright 1987-89 Apple Computer, Inc
  8. ;;
  9. ;;  This file implements a full error-checked interface to Quickdraw.
  10. ;;  It is meant to be useful both in programs and as an example of how to use
  11. ;;  the low-level interface to the Mac.
  12. ;;
  13. ;;  You can compile selected portions of this file, but if you do, make sure to
  14. ;;  include the macros and utility functions from the top.
  15. ;;
  16. ;;  Because these functions perform a view-focus on every drawing command,
  17. ;;  they can be slow.  For faster drawing you should only focus the view
  18. ;;  once, and then issue a series of drawing commands.  You can use
  19. ;;  this file as an example of how to call the Quickdraw traps directly
  20. ;;  in such a situation.
  21. ;;
  22.  
  23. ;;;;;;;
  24. ;;
  25. ;; Mod history
  26. ;;
  27. ;; 10/16/91 bill PSZ's simplification of with-rectangle-arg
  28. ;; ------------- 2.0b3
  29. ;; 08/26/91 bill downward-function -> dynamic-extent
  30. ;; 08/17/91 bill (pset x :record.slot v) -> (setf (pref x :record.slot) v)
  31. ;;               No more (require-interface :quickdraw), autoloading is faster.
  32. ;; 07/09/91 bill rref & rset -> pref/href & pset/hset
  33. ;; ------------- 2.0b2
  34. ;; 02/20/91 bill with-pointers in copy-bits, *32-bit-qd-pen-modes* in mode-arg
  35. ;;--------------- 2.0b1
  36. ;;
  37.  
  38. (in-package :ccl)
  39.  
  40. (eval-when (:compile-toplevel :load-toplevel :execute)
  41.   (export '(clip-region set-clip-region clip-rect pen-show pen-hide
  42.             pen-shown-p pen-position pen-size set-pen-size pen-mode
  43.             set-pen-mode pen-pattern set-pen-pattern pen-state
  44.             set-pen-state pen-normal move-to move line-to line
  45.             offset-rect inset-rect intersect-rect union-rect point-in-rect-p
  46.             points-to-rect point-to-angle equal-rect empty-rect-p frame-rect
  47.             paint-rect erase-rect invert-rect fill-rect frame-oval paint-oval
  48.             erase-oval invert-oval fill-oval frame-round-rect paint-round-rect
  49.             erase-round-rect invert-round-rect fill-round-rect frame-arc
  50.             paint-arc erase-arc invert-arc fill-arc new-region dispose-region
  51.             copy-region set-empty-region set-rect-region open-region close-region
  52.             offset-region inset-region intersect-region union-region
  53.             difference-region xor-region point-in-region-p rect-in-region-p
  54.             equal-region-p empty-region-p frame-region paint-region erase-region
  55.             invert-region fill-region start-picture get-picture draw-picture
  56.             kill-picture start-polygon get-polygon kill-polygon offset-polygon
  57.             frame-polygon paint-polygon erase-polygon invert-polygon fill-polygon
  58.             local-to-global global-to-local get-pixel scale-point map-point
  59.             map-rect map-region map-polygon make-bitmap copy-bits scroll-rect
  60.             origin set-origin)
  61.           :ccl))
  62.  
  63.  
  64. (defmacro with-rectangle-arg ((var left &optional top right bottom) &body body)
  65.   "takes a rectangle, two points, or four coordinates and makes a rectangle.
  66. body is evaluated with VAR bound to that rectangle."
  67.   `(rlet ((,var :rect))
  68.      (setup-rect ,var ,left ,top ,right ,bottom)
  69.      ,@body))
  70.  
  71. (defun setup-rect (rect left top right bottom)
  72.   (cond (bottom
  73.          (setf (pref rect rect.topleft) (make-point left top))
  74.          (setf (pref rect rect.bottomright) (make-point right bottom)))
  75.         (right
  76.          (error "Illegal rectangle arguments: ~s ~s ~s ~s"
  77.                 left top right bottom))
  78.         (top
  79.          (setf (pref rect rect.topleft) (make-point left nil))
  80.          (setf (pref rect rect.bottomright) (make-point top nil)))
  81.         (t (%setf-macptr rect left))))
  82.  
  83. (defvar *32-bit-qd-pen-modes*
  84.   '((:blend . 32)
  85.     (:addPin . 33)
  86.     (:addOver . 34)
  87.     (:subPin . 35)
  88.     (:transparent . 36)
  89.     (:adMax . 37)
  90.     (:subOver . 38)
  91.     (:adMin . 39)
  92.     (:hilite . 50)))
  93.  
  94. (defun mode-arg (thing)
  95.   (or
  96.    (and (fixnump thing) (<= 0 thing 64) thing)
  97.    (position thing *pen-modes*)
  98.    (cdr (assq thing *32-bit-qd-pen-modes*))
  99.    (error "Unknown pen mode: ~a" thing)))
  100.  
  101. (defmethod origin ((view simple-view))
  102.   (view-scroll-position view))
  103.  
  104. (defmethod set-origin ((view simple-view) h &optional v)
  105.   (set-view-scroll-position view h v nil))
  106.  
  107.  
  108. (defmethod clip-region ((view simple-view) &optional (save-region (#_NewRgn)))
  109.   (with-focused-view view
  110.     (#_GetClip save-region))
  111.   save-region)
  112.  
  113. (defmethod set-clip-region ((view simple-view) new-region)
  114.   (with-focused-view view
  115.     (#_SetClip new-region))
  116.   new-region)
  117.  
  118. (defmethod clip-rect ((view simple-view) left &optional top right bot)
  119.   (with-rectangle-arg (r left top right bot)
  120.     (with-focused-view view
  121.       (#_ClipRect r)))
  122.   nil)
  123.  
  124. (defmethod pen-show ((view simple-view))
  125.   (setf (pref (wptr view) grafport.pnvis) 0)
  126.   nil)
  127.  
  128. (defmethod pen-hide ((view simple-view))
  129.   (setf (pref (wptr view) grafport.pnvis) -1)
  130.   nil)
  131.  
  132. (defmethod pen-shown-p ((view simple-view))
  133.   (> (pref (wptr view) grafport.pnvis) -1))
  134.  
  135. (defmethod pen-position ((view simple-view))
  136.  (with-focused-view view
  137.    (pref (wptr view) windowRecord.pnloc)))
  138.  
  139. (defmethod pen-size ((view simple-view))
  140.   (pref (wptr view) windowRecord.pnsize))
  141.  
  142. (defmethod set-pen-size ((view simple-view) h &optional v &aux (pt (make-point h v)))
  143.   (with-port (wptr view) (#_PenSize :long pt))
  144.   pt)
  145.  
  146. (defmethod pen-mode ((view simple-view))
  147.   (elt *pen-modes* (pref (wptr view) windowRecord.pnmode)))
  148.  
  149. (defmethod set-pen-mode ((view simple-view) new-mode)
  150.   (with-port (wptr view) (#_PenMode (mode-arg new-mode))))
  151.  
  152. (defmethod pen-pattern ((view simple-view) &optional
  153.                         (save-pat (make-record (:pattern :storage :pointer))))
  154.   (copy-record
  155.    (pref (wptr view) windowRecord.pnPat) (:pattern :storage :pointer) save-pat))
  156.  
  157. (defmethod set-pen-pattern ((view simple-view) new-pattern)
  158.   (with-port (wptr view)
  159.     (#_PenPat new-pattern))
  160.   new-pattern)
  161.  
  162. (defmethod pen-state ((view simple-view) &optional (save-state (make-record :penstate)))
  163.  (with-focused-view view
  164.    (#_GetPenState save-state))
  165.  save-state)
  166.  
  167. (defmethod set-pen-state ((view simple-view) new-state)
  168.   (with-focused-view view
  169.     (#_SetPenState new-state))
  170.   new-state)
  171.  
  172. (defmethod pen-normal ((view simple-view))
  173.   (with-focused-view view (#_PenNormal)))
  174.  
  175. (defmethod move-to ((view simple-view) h &optional v)
  176.   (with-focused-view view (#_MoveTo :long (setq h (make-point h v))))
  177.   h)
  178.  
  179. (defmethod move ((view simple-view) h &optional v)
  180.   (with-focused-view view (#_Move :long (setq h (make-point h v))))
  181.   h)
  182.  
  183. (defmethod line-to ((view simple-view) h &optional v)
  184.   (with-focused-view view (#_LineTo :long (setq h (make-point h v))))
  185.   h)
  186.  
  187. (defmethod line ((view simple-view) h &optional v)
  188.   (with-focused-view view (#_Line :long (setq h (make-point h v))))
  189.   h)
  190.  
  191. (defun offset-rect (rect h &optional v)
  192.   (#_OffsetRect :ptr rect :long (make-point h v))
  193.   rect)
  194.  
  195. (defun inset-rect (rect h &optional v)
  196.   (#_InsetRect :ptr rect :long (make-point h v))
  197.   rect)
  198.  
  199. (defun intersect-rect (rect1 rect2 dest-rect)
  200.   (#_SectRect rect1 rect2 dest-rect)
  201.   dest-rect)
  202.  
  203. (defun union-rect (rect1 rect2 dest-rect)
  204.   (#_UnionRect rect1 rect2 dest-rect)
  205.   dest-rect)
  206.  
  207. (defun point-in-rect-p (rect h &optional v)
  208.   (#_PtInRect (make-point h v) rect))
  209.  
  210. (defun points-to-rect (point1 point2 dest-rect)
  211.   (#_Pt2Rect (make-point point1 nil) (make-point point2 nil) dest-rect)
  212.   dest-rect)
  213.  
  214. (defun point-to-angle (rect h &optional v)
  215.   (%stack-block ((ip 4))
  216.     (#_PtToAngle rect (make-point h v) ip)
  217.     (%get-word ip)))
  218.  
  219. (defun equal-rect (rect1 rect2)
  220.   (#_EqualRect rect1 rect2))
  221.  
  222. (defun empty-rect-p (left &optional top right bot)
  223.   (with-rectangle-arg (r left top right bot)
  224.     (#_EmptyRect r)))
  225.  
  226. (defmethod frame-rect ((view simple-view) left &optional top right bot)
  227.  (with-focused-view view
  228.    (with-rectangle-arg (r left top right bot) (#_FrameRect r))))
  229.  
  230. (defmethod paint-rect ((view simple-view) left &optional top right bot)
  231.   (with-focused-view view
  232.     (with-rectangle-arg (r left top right bot) (#_PaintRect r))))
  233.  
  234. (defmethod erase-rect ((view simple-view) left &optional top right bot)
  235.   (with-focused-view view
  236.     (with-rectangle-arg (r left top right bot) (#_EraseRect r))))
  237.  
  238. (defmethod invert-rect ((view simple-view) left &optional top right bot)
  239.   (with-focused-view view
  240.     (with-rectangle-arg (r left top right bot) (#_InvertRect r))))
  241.  
  242. (defmethod fill-rect ((view simple-view) pattern left &optional top right bot)
  243.   (with-focused-view view
  244.     (with-rectangle-arg (r left top right bot)
  245.        (#_FillRect r pattern))))
  246.  
  247. (defmethod frame-oval ((view simple-view) left &optional top right bot)
  248.  (with-focused-view view
  249.    (with-rectangle-arg (r left top right bot) (#_FrameOval r))))
  250.  
  251. (defmethod paint-oval ((view simple-view) left &optional top right bot)
  252.   (with-focused-view view
  253.     (with-rectangle-arg (r left top right bot) (#_PaintOval r))))
  254.  
  255. (defmethod erase-oval ((view simple-view) left &optional top right bot)
  256.   (with-focused-view view
  257.     (with-rectangle-arg (r left top right bot) (#_EraseOval r))))
  258.  
  259. (defmethod invert-oval ((view simple-view) left &optional top right bot)
  260.   (with-focused-view view
  261.     (with-rectangle-arg (r left top right bot) (#_InvertOval r))))
  262.  
  263. (defmethod fill-oval ((view simple-view) pattern left &optional top right bot)
  264.   (with-focused-view view
  265.     (with-rectangle-arg (r left top right bot)
  266.        (#_FillOval r pattern))))
  267.  
  268. (defmethod frame-round-rect ((view simple-view) oval-width oval-height 
  269.                              left &optional top right bot)
  270.  (with-focused-view view
  271.    (with-rectangle-arg (r left top right bot)
  272.       (#_FrameRoundRect r oval-width oval-height))))
  273.  
  274. (defmethod paint-round-rect ((view simple-view) oval-width oval-height 
  275.                              left &optional top right bot)
  276.  (with-focused-view view
  277.    (with-rectangle-arg (r left top right bot)
  278.       (#_PaintRoundRect r oval-width oval-height))))
  279.  
  280. (defmethod erase-round-rect ((view simple-view) oval-width oval-height 
  281.                              left &optional top right bot)
  282.  (with-focused-view view
  283.    (with-rectangle-arg (r left top right bot)
  284.       (#_EraseRoundRect r oval-width oval-height))))
  285.  
  286. (defmethod invert-round-rect ((view simple-view) oval-width oval-height 
  287.                               left &optional top right bot)
  288.  (with-focused-view view
  289.    (with-rectangle-arg (r left top right bot)
  290.       (#_InvertRoundRect r oval-width oval-height))))
  291.  
  292. (defmethod fill-round-rect ((view simple-view) pattern oval-width oval-height 
  293.                             left &optional top right bot)
  294.   (with-focused-view view
  295.     (with-rectangle-arg (r left top right bot)
  296.        (#_FillRoundRect r oval-width oval-height pattern))))
  297.  
  298. (defmethod frame-arc ((view simple-view) start-angle arc-angle 
  299.                       left &optional top right bot)
  300.  (with-focused-view view
  301.    (with-rectangle-arg (r left top right bot)
  302.       (#_FrameArc r start-angle arc-angle))))
  303.  
  304. (defmethod paint-arc ((view simple-view) start-angle arc-angle 
  305.                       left &optional top right bot)
  306.  (with-focused-view view
  307.    (with-rectangle-arg (r left top right bot)
  308.       (#_PaintArc r start-angle arc-angle))))
  309.  
  310. (defmethod erase-arc ((view simple-view) start-angle arc-angle 
  311.                       left &optional top right bot)
  312.  (with-focused-view view
  313.    (with-rectangle-arg (r left top right bot)
  314.       (#_EraseArc r start-angle arc-angle))))
  315.  
  316. (defmethod invert-arc ((view simple-view) start-angle arc-angle 
  317.                        left &optional top right bot)
  318.  (with-focused-view view
  319.    (with-rectangle-arg (r left top right bot)
  320.       (#_InvertArc r start-angle arc-angle))))
  321.  
  322. (defmethod fill-arc ((view simple-view) pattern start-angle arc-angle
  323.                      left &optional top right bot)
  324.   (with-focused-view view
  325.     (with-rectangle-arg (r left top right bot)
  326.        (#_FillArc r start-angle arc-angle pattern))))
  327.  
  328. ;;;Regions
  329.  
  330. (defun new-region ()
  331.   (#_NewRgn))
  332.  
  333. (defun dispose-region (region)
  334.   (#_DisposeRgn region))
  335.  
  336. (defun copy-region (region &optional (dest-region (new-region)))
  337.   (#_CopyRgn region dest-region)
  338.   dest-region)
  339.  
  340. (defun set-empty-region (region)
  341.   (#_SetEmptyRgn region)
  342.   region)
  343.  
  344. (defun set-rect-region (region left &optional top right bot)
  345.   (with-rectangle-arg (r left top right bot)
  346.    (#_RectRgn region r))
  347.   region)
  348.  
  349. (defmethod open-region ((view simple-view))
  350.   (let ((wptr (wptr view)))
  351.     (unless (%null-ptr-p (pref wptr windowRecord.rgnSave))
  352.       (error "Region already open for window: ~a" view))
  353.     (with-port wptr (#_OpenRgn))))
  354.  
  355. (defmethod close-region ((view simple-view) &optional (dest-region (new-region) dp))
  356.   (let ((wptr (wptr view)))
  357.     (if (%null-ptr-p (pref wptr windowRecord.rgnSave))
  358.       (progn 
  359.         (if (not dp) (dispose-region dest-region))
  360.         (error "Region is not open for window: ~a" view)))
  361.     (with-port wptr
  362.       (#_CloseRgn dest-region)))
  363.   dest-region)
  364.  
  365. (defun offset-region (region h &optional v)
  366.   (#_OffsetRgn :ptr region :long (make-point h v))
  367.   region)
  368.  
  369. (defun inset-region (region h &optional v)
  370.   (#_InsetRgn :ptr region :long (make-point h v))
  371.   region)
  372.  
  373. (defun intersect-region (region1 region2 &optional (dest-region (new-region)))
  374.   (#_SectRgn region1 region2 dest-region)
  375.   dest-region)
  376.  
  377. (defun union-region (region1 region2 &optional (dest-region (new-region)))
  378.   (#_UnionRgn region1 region2 dest-region)
  379.   dest-region)
  380.  
  381. (defun difference-region (region1 region2 &optional (dest-region (new-region)))
  382.   (#_DiffRgn region1 region2 dest-region)
  383.   dest-region)
  384.  
  385. (defun xor-region (region1 region2 &optional (dest-region (new-region)))
  386.   (#_XorRgn region1 region2 dest-region)
  387.   dest-region)
  388.  
  389. (defun point-in-region-p (region h &optional v)
  390.   (#_PtInRgn (make-point h v) region))
  391.  
  392. (defun rect-in-region-p (region left &optional top right bot)
  393.  (with-rectangle-arg (r left top right bot)
  394.    (#_RectInRgn r region)))
  395.  
  396. (defun equal-region-p (region1 region2)
  397.   (#_EqualRgn region1 region2))
  398.  
  399. (defun empty-region-p (region)
  400.   (#_EmptyRgn region))
  401.  
  402. (defmethod frame-region ((view simple-view) region)
  403.   (with-focused-view view (#_FrameRgn region)))
  404.  
  405. (defmethod paint-region ((view simple-view) region)
  406.   (with-focused-view view (#_PaintRgn region)))
  407.  
  408. (defmethod erase-region ((view simple-view) region)
  409.   (with-focused-view view (#_EraseRgn region)))
  410.  
  411. (defmethod invert-region ((view simple-view) region)
  412.   (with-focused-view view (#_InvertRgn region)))
  413.  
  414. (defmethod fill-region ((view simple-view) pattern region)
  415.   (with-focused-view view 
  416.     (#_FillRgn region pattern)))
  417.  
  418. ;;;Pictures
  419.  
  420. (defmethod start-picture ((view simple-view) &optional left top right bottom)
  421.   (with-macptrs (portrect)
  422.     (let ((wptr (wptr view)))
  423.       (unless (%null-ptr-p (pref wptr windowRecord.picsave))
  424.         (error "A picture may not be started for window: ~a.
  425.            since one is already started" view))
  426.       (unless left (setq left (%setf-macptr portrect (pref wptr windowRecord.portrect)))))
  427.     (with-rectangle-arg (r left top right bottom)
  428.       (with-focused-view view
  429.         (#_cliprect r)
  430.         (setf (view-get view 'my-hPic) (#_OpenPicture r))))
  431.     nil))
  432.  
  433. (defmethod get-picture ((view simple-view))
  434.   (let ((my-hPic (view-get view 'my-hPic))
  435.         (wptr (wptr view)))
  436.     (if (and my-hPic (not (%null-ptr-p (pref wptr windowRecord.picSave))))
  437.       (prog1
  438.         my-hPic
  439.         (with-port wptr (#_ClosePicture))
  440.         (setf (view-get view 'my-hPic) nil))
  441.       (error "Picture for window: ~a is not started" view))))
  442.  
  443. (defmethod draw-picture ((view simple-view) picture &optional left top right bottom)
  444.  (cond ((not left)
  445.         (setq left (href picture picture.picFrame.topleft)
  446.               top (href picture picture.picFrame.bottomright)))
  447.        ((pointerp left)
  448.         ())  ;everythings fine
  449.        ((and (not right)
  450.              (not top))
  451.         (setq top
  452.               (add-points left
  453.                           (subtract-points
  454.                            (href picture picture.picframe.bottomright)
  455.                            (href picture picture.picframe.topleft))))))
  456.  (with-rectangle-arg (r left top right bottom)
  457.    (with-focused-view view
  458.      (#_DrawPicture picture r)))
  459.  picture)
  460.  
  461. (defun kill-picture (picture)
  462.   (#_KillPicture picture))
  463.  
  464. (defmethod start-polygon ((view simple-view))
  465.   (let ((wptr (wptr view)))
  466.     (unless (%null-ptr-p (pref wptr windowRecord.polysave))
  467.       (error "A new polygon may not be started for window: ~a.
  468.            since one is already started" view))
  469.     (with-port wptr (setf (view-get view 'my-poly) (#_OpenPoly))))
  470.   nil)
  471.  
  472. (defmethod get-polygon ((view simple-view))
  473.   (let ((my-poly (view-get view 'my-poly))
  474.         (wptr (wptr view)))
  475.     (if (and my-poly (not (%null-ptr-p (pref wptr windowRecord.polysave))))
  476.       (prog1
  477.         my-poly
  478.         (with-port wptr (#_ClosePoly))
  479.         (setq my-poly nil))
  480.       (error "Polygon for window: ~a has not been started" view))))
  481.  
  482. (defun kill-polygon (polygon)
  483.   (#_KillPoly polygon))
  484.  
  485. (defun offset-polygon (polygon h &optional v)
  486.   (#_OffsetPoly :ptr polygon :long (make-point h v))
  487.   polygon)
  488.  
  489. (defmethod frame-polygon ((view simple-view) polygon)
  490.   (with-focused-view view (#_FramePoly polygon)))
  491.  
  492. (defmethod paint-polygon ((view simple-view) polygon)
  493.   (with-focused-view view (#_PaintPoly polygon)))
  494.  
  495. (defmethod erase-polygon ((view simple-view) polygon)
  496.   (with-focused-view view (#_ErasePoly polygon)))
  497.  
  498. (defmethod invert-polygon ((view simple-view) polygon)
  499.   (with-focused-view view (#_InvertPoly polygon)))
  500.  
  501. (defmethod fill-polygon ((view simple-view) pattern polygon)
  502.  (with-focused-view view
  503.    (#_FillPoly polygon pattern)))
  504.  
  505.  
  506.  
  507. (defmethod local-to-global ((view simple-view) h &optional v)
  508.   (with-focused-view view
  509.     (rlet ((p :point))
  510.       (%put-long p (make-point h v))
  511.       (#_LocalToGlobal p)
  512.       (%get-long p))))
  513.  
  514. (defmethod global-to-local ((view simple-view) h &optional v)
  515.   (with-focused-view view
  516.     (rlet ((p :point))
  517.       (%put-long p (make-point h v))
  518.       (#_GlobalToLocal p)
  519.       (%get-long p))))
  520.  
  521. (defmethod get-pixel ((view simple-view) h &optional v)
  522.   (with-focused-view view
  523.     (setq h (make-point h v))
  524.     (if (#_PtInRgn h (pref (wptr view) windowRecord.visrgn))
  525.       (#_GetPixel :long h :boolean))))
  526.  
  527. (defun scale-point (source-rect dest-rect h &optional v)
  528.   (rlet ((pt :point))
  529.     (%put-long pt (make-point h v))
  530.     (#_ScalePt pt source-rect dest-rect)
  531.     (%get-long pt)))
  532.  
  533. (defun map-point (source-rect dest-rect h &optional v)
  534.   (rlet ((pt :point))
  535.     (%put-long pt (make-point h v))
  536.     (#_MapPt pt source-rect dest-rect)
  537.     (%get-long pt)))
  538.  
  539. (defun map-rect (source-rect dest-rect rect)
  540.   (#_MapRect rect source-rect dest-rect)
  541.   rect)
  542.  
  543. (defun map-region (source-rect dest-rect region)
  544.   (#_MapRgn region source-rect dest-rect)
  545.   region)
  546.  
  547. (defun map-polygon (source-rect dest-rect polygon)
  548.   (#_MapPoly polygon source-rect dest-rect)
  549.   polygon)
  550.  
  551. (defun make-bitmap (left &optional top right bottom &aux rowbytes bm)
  552.   (with-rectangle-arg (r left top right bottom)
  553.     (setq rowbytes 
  554.           (logand
  555.            #xfffe 
  556.            (+ 2  (ash (- (pref r rect.right) (pref r rect.left) 1) -3))))
  557.     (setq bm 
  558.           (#_NewPtr :check-error
  559.                     (+ 14 (* rowbytes (- (pref r rect.bottom) (pref r rect.top))))))
  560.     (setf (pref bm bitmap.bounds) r)
  561.     (setf (pref bm bitmap.rowbytes) rowbytes)
  562.     (setf (pref bm bitmap.baseaddr) (%inc-ptr bm 14)))
  563.   bm)
  564.  
  565.  
  566. (defun copy-bits (source-bitmap dest-bitmap source-rect dest-rect
  567.                                 &optional (mode 0) mask-region)
  568.   (with-macptrs ((mask-region (if mask-region mask-region (%null-ptr))))
  569.     (with-pointers ((sb source-bitmap)
  570.                     (db dest-bitmap))
  571.       (#_CopyBits sb db source-rect dest-rect (mode-arg mode) mask-region))))
  572.  
  573. (defmethod scroll-rect ((view simple-view) rect dh &optional dv)
  574.   "ignores any clipping regions"
  575.   (with-focused-view view
  576.     (let* ((reg (#_newrgn)))
  577.       (#_ScrollRect :ptr rect
  578.                     :long (make-point dh dv)
  579.                     :ptr reg)
  580.       (#_invalrgn reg)
  581.       (#_disposergn reg))))
  582.  
  583. (provide 'quickdraw)
  584. (pushnew :quickdraw *features*)
  585.